home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / oobr / br.el < prev    next >
Encoding:
Text File  |  1995-07-14  |  69.0 KB  |  1,991 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         br.el
  4. ;; SUMMARY:      Browse object-oriented code.
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     matching, oop, tools
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Motorola Inc.
  10. ;;
  11. ;; ORIG-DATE:    12-Dec-89
  12. ;; LAST-MOD:     12-Jul-95 at 14:46:40 by Bob Weiner
  13. ;;
  14. ;; Copyright (C) 1989-1995  Free Software Foundation, Inc.
  15. ;; See the file BR-COPY for license information.
  16. ;;
  17. ;; This file is part of the OO-Browser.
  18. ;;
  19. ;; DESCRIPTION:  
  20. ;; DESCRIP-END.
  21.  
  22. ;;; ************************************************************************
  23. ;;; Other required Elisp libraries
  24. ;;; ************************************************************************
  25.  
  26. (require 'br-lib)
  27.  
  28. ;;; ************************************************************************
  29. ;;; Public variables
  30. ;;; ************************************************************************
  31.  
  32. (defvar br-c-tags-flag t
  33.   "*Non-nil means add C constructs when building C-based language Environments.")
  34.  
  35. (defvar br-directory nil
  36.   "Directory in which OO-Browser executable and help files are kept.")
  37.  
  38. (defconst br-feature-signature-regexp "[:|,]"
  39.   "Regular expression that matches a feature signature but not a class name.")
  40.  
  41. (defvar br-inherited-features-flag t
  42.   "*If non-nil (the default), feature/element listings include all inherited features.
  43. If nil, only those features lexically included within a class are shown.")
  44.  
  45. (defvar br-inhibit-version nil
  46.   "*Personal setting which if non-nil, skips version/credit information upon startup.
  47. The default should be left as nil, since new users may find this helpful.")
  48.  
  49. (defvar br-invert-ancestors nil
  50.   "*Personal setting which if non-nil makes ancestors appear as do other inheritance listings.
  51. That is, parents appear above children, rather than the default, which is the
  52. reverse.")
  53.  
  54. (defvar br-keep-viewed-classes nil
  55.   "*Personal setting which if non-nil means leave all viewed classes around for later selection.  
  56. Non-nil deletes last viewed class when a new one is displayed.   Note this
  57. does not affect classes displayed for editing, all such classes are left
  58. around.")
  59.  
  60. (defconst br-min-width-window 25
  61.   "*Minimum width of a browser class list window.
  62. This together with the frame width determines the number of such windows.")
  63.  
  64. ;; -f treats upper and lower case the same in sorting, also makes 'a' sort
  65. ;; list before '[a]', so default classes appear at the end of the list,
  66. ;; typically.
  67. ;; -u leaves only unique elements in the sorted list
  68. (defvar br-sort-options "-fu"
  69.   "*String of options to send to the operating system `sort' command.
  70. Use nil for none.  This is used by the OO-Browser (br-order) command only
  71. under Emacs 18.")
  72.  
  73. ;;; ************************************************************************
  74. ;;; Public macros
  75. ;;; ************************************************************************
  76.  
  77. (if (fboundp 'window-highest-p)
  78.     (defun br-non-listing-window-p ()
  79.       "Is the selected window a non-OO-Browser listing window?"
  80.       ;; Top of window is not at top of frame.
  81.       (not (window-highest-p (selected-window))))
  82.   (defun br-non-listing-window-p ()
  83.     "Is the selected window a non-OO-Browser listing window?"
  84.     ;; Top of window is not at top of frame.
  85.     (/= (nth 1 (window-edges)) br-top-of-frame)))
  86.  
  87. (if (fboundp 'window-highest-p)
  88.     (defun br-listing-window-p ()
  89.       "Is the selected window an OO-Browser listing window?"
  90.       (window-highest-p (selected-window)))
  91.   (defun br-listing-window-p ()
  92.     "Is the selected window an OO-Browser listing window?"
  93.     ;; Top of window is at top of frame.
  94.     (= (nth 1 (window-edges)) br-top-of-frame)))
  95.  
  96. ;;; ************************************************************************
  97. ;;; Public functions
  98. ;;; ************************************************************************
  99.  
  100. (defun br-browse ()
  101.   "Internally invoke the OO-Browser, for browsing class hierarchies.
  102. Use \\[br-help] and \\[br-help-ms] for help on browser usage."
  103.   (interactive)
  104.   ;; If not already in the browser, save window config.
  105.   (if (br-in-browser)
  106.       nil
  107.     (setq *br-prev-wconfig* (current-window-configuration)
  108.       br-in-browser (selected-frame))
  109.     ;; If were previously in the browser, restore its saved window config,
  110.     ;; otherwise, set up from scratch.
  111.     (if *br-save-wconfig*
  112.     (set-window-configuration *br-save-wconfig*)
  113.       (br-window-setup)
  114.       (if br-inhibit-version
  115.       (br-top-classes t)
  116.     (br-version)
  117.     (message "Press {h} for for help.")
  118.     ;; Display all classes.
  119.     (br-top-classes t)
  120.     (message "Press {h} for for help.")
  121.     ;; Wait for 60 seconds or until a single key sequence is given.
  122.     (sit-for 60)
  123.     (message ""))
  124.       (br-help))
  125.     (run-hooks 'br-mode-hook
  126.            (intern (concat "br-" br-lang-prefix "mode-hook")))))
  127.  
  128. ;;;###autoload
  129. (defun br-add-class-file (&optional class-path lib-table-p save-file)
  130.   "Add a file of classes to the current Environment.
  131. Interactively or when optional CLASS-PATH is nil, CLASS-PATH defaults to the
  132. current buffer file pathname.  If optional LIB-TABLE-P is non-nil, add to
  133. Library Environment, otherwise add to System Environment.  If optional
  134. SAVE-FILE is t, the Environment is then stored to the filename given by
  135. 'br-env-file'.  If SAVE-FILE is non-nil and not t, its string value is used
  136. as the file to which to save the Environment."
  137.   (interactive
  138.     (list (read-file-name (concat "Class file name to add"
  139.                   (if buffer-file-name
  140.                       (concat " (default \""
  141.                           (file-name-nondirectory
  142.                         buffer-file-name)
  143.                           "\")"))
  144.                   ": ")
  145.               nil buffer-file-name t)
  146.       (y-or-n-p "Add to Library, rather than System tables? ")
  147.       (y-or-n-p
  148.         (concat "Save tables after addition to " br-env-file "? "))))
  149.   (let* ((paths-parents-cons
  150.        (let ((br-view-file-function 'br-insert-file-contents))
  151.          (br-get-classes-from-source class-path)))
  152.      (classes (car paths-parents-cons))
  153.      (parents (cdr paths-parents-cons))
  154.      (paths-key class-path)
  155.      (path-htable (br-get-htable (if lib-table-p "lib-paths" "sys-paths")))
  156.      (par-htable (br-get-htable
  157.                (if lib-table-p "lib-parents" "sys-parents")))
  158.      (child-htable (br-get-children-htable)))
  159.     (mapcar
  160.       (function
  161.     (lambda (class)
  162.       (br-add-to-paths-htable class paths-key path-htable)))
  163.       classes)
  164.     (mapcar
  165.       (function
  166.     (lambda (parent-cons)
  167.       (hash-add (car parent-cons) (cdr parent-cons) par-htable)))
  168.       parents)
  169.     (br-env-set-htables)
  170.     (let ((child) (par-list) children)
  171.       (mapcar
  172.     (function
  173.       (lambda (parent-cons)
  174.         (setq child (cdr parent-cons)
  175.           par-list (car parent-cons))
  176.         (mapcar
  177.           (function
  178.         (lambda (parent)
  179.           (setq children (hash-get parent child-htable))
  180.           (or (br-member child children)
  181.               (hash-add (cons child children) parent child-htable))))
  182.           par-list)))
  183.     parents)))
  184.   (cond ((eq save-file nil))
  185.     ((eq save-file t) (br-env-save))
  186.     ((br-env-save save-file))))
  187.  
  188. (defun br-ancestors (&optional arg features-flag)
  189.   "Display ancestor tree whose root is the current class.
  190. With optional prefix ARG, display all ancestor trees whose roots are in the
  191. current listing.  If ARG = -1 or 'br-invert-ancestors' is t, the current
  192. class ancestry tree is inverted.  That is, it shows branches going down
  193. towards the root class, so that parents appear above children.  If ARG < -1 or
  194. 'br-invert-ancestors' is t and ARG > 1, then the ancestry trees of all
  195. classes in the current listing are inverted.
  196.  
  197. Optional second argument, FEATURES-FLAG non-nil means display features under
  198. each ancestor class."
  199.   (interactive "p")
  200.   (or arg (setq arg 1))
  201.   (if br-invert-ancestors (setq arg (- arg)))
  202.   (let* ((class-list
  203.       (if (and (/= arg 1) (/= arg -1))
  204.           (br-this-level-classes)
  205.         (list (br-find-class-name))))
  206.      (parents (delq nil (mapcar (function
  207.                      (lambda (c) (br-get-parents c)))
  208.                     class-list))))
  209.     (cond ((or parents
  210.            (and features-flag
  211.             (if (/= 1 (length class-list))
  212.             t ;; Assume some class will have features.
  213.               ;; This class must have features.
  214.               (br-list-features (car class-list)))))
  215.        (if (and (/= arg 1) (/= arg -1))
  216.            (message "Computing %s..."
  217.             (if features-flag "features" "ancestors")))
  218.        (if features-flag
  219.            (progn
  220.          (br-add-level-hist)
  221.          (br-next-buffer))
  222.          (let ((child-level (br-buffer-level)))
  223.            (br-add-level-hist)
  224.            (br-next-listing-window -1)
  225.            (br-next-buffer (concat "p" child-level))))
  226.        (let (buffer-read-only)
  227.          (cond ((>= arg 0)
  228.             (br-ancestor-trees-inverted class-list))
  229.            (t
  230.             (br-ancestor-trees class-list))))
  231.        (goto-char (point-min))
  232.        (if (and (/= arg 1) (/= arg -1))
  233.            (message "Computing %s...Done"
  234.             (if features-flag "features" "ancestors"))))
  235.       (t
  236.        (message "No %s." (if features-flag "features" "ancestors"))
  237.        (beep)))))
  238.  
  239. (defun br-at (&optional arg)
  240.   "Display current class location in the inheritance graph.
  241. The class is displayed among both its ancestors and descendants.
  242. With optional prefix ARG, display location for all classes in the current
  243. listing."
  244.   (interactive "P")
  245.   (let* ((parent)
  246.      (parent-list
  247.        (if arg
  248.            (br-this-level-classes)
  249.          (list (setq parent (br-find-class-name))))))
  250.     (if arg 
  251.     (message "Computing class locations...")
  252.       (br-narrow-to-class))
  253.     (br-add-level-hist)
  254.     (br-next-buffer)
  255.     (let (buffer-read-only)
  256.       (br-descendant-trees (br-ancestor-roots parent-list))
  257.       (goto-char (point-min))
  258.       (if arg
  259.       (message "Computing class locations...Done")
  260.     (re-search-forward (concat "\\(^\\|[ \t]+\\)" parent "$"))
  261.     (goto-char (match-end 1))
  262.     (recenter '(4))))))
  263.  
  264. (defun br-categories (&optional arg)
  265.   "Display categories directly associated with the current class.
  266. This does not include any categories which the class inherits.
  267. With optional prefix ARG, display categories of all classes in the current
  268. listing."
  269.   (interactive "P")
  270.   (let ((has-categories)
  271.     class-list categories class-and-categories)
  272.     (setq class-list (cond (arg
  273.                 (message "Computing class categories...")
  274.                 (br-this-level-classes))
  275.                (t 
  276.                 (list (br-find-class-name))))
  277.       categories
  278.       (delq nil (mapcar
  279.              (function
  280.               (lambda (class)
  281.             (setq class-and-categories (br-list-categories class)
  282.                   has-categories (or has-categories
  283.                          class-and-categories))
  284.             (cons class class-and-categories)))
  285.              class-list)))
  286.     (cond ((not class-list)
  287.        (beep)
  288.        (message "(OO-Browser):  Apply 'br-categories' to a class."))
  289.       ((not has-categories)
  290.        (message "No class categories.") (beep))
  291.       (t
  292.        (br-add-level-hist)
  293.        (br-next-buffer nil)
  294.        (let (buffer-read-only done-set class)
  295.          (mapcar
  296.           (function
  297.            (lambda (class-and-categories)
  298.          (setq class (car class-and-categories))
  299.          (if (not (br-set-cons done-set class))
  300.              (insert class " ...\n")
  301.            ;; Class successfully added to set, so it has not been
  302.            ;; listed before.
  303.            (insert class "\n")
  304.            (br-insert-features (cdr class-and-categories) 2))))
  305.           categories))
  306.        (message "Computing class categories...Done")
  307.        (goto-char (point-min))))))
  308.  
  309. (defun br-children (&optional arg)
  310.   "Display children of current class.
  311. With optional prefix ARG, display children of all the classes in the current
  312. listing."
  313.   (interactive "P")
  314.   (let ((class-list (cond (arg
  315.                (message "Computing children...")
  316.                (br-this-level-classes))
  317.               (t
  318.                (list (br-find-class-name)))))
  319.     (has-children)
  320.     children children-list)
  321.     (setq children-list (delq nil (mapcar
  322.                    (function
  323.                     (lambda (parent)
  324.                       (setq children
  325.                         (br-get-children parent)
  326.                         has-children
  327.                         (or has-children children))
  328.                       (cons parent children)))
  329.                    class-list)))
  330.     (cond ((not children-list)
  331.        (beep)
  332.        (message "(OO-Browser):  Apply 'br-children' to a class."))
  333.       ((not has-children)
  334.        (message "No children.") (beep))
  335.       (t
  336.        (br-add-level-hist)
  337.        (br-next-buffer nil)
  338.        (let (buffer-read-only done-set parent)
  339.          (mapcar
  340.           (function
  341.            (lambda (parent-children-cons)
  342.          (setq parent (car parent-children-cons))
  343.          (if (not (br-set-cons done-set parent))
  344.              (insert parent " ...\n")
  345.            ;; Class successfully added to set, so it has not been
  346.            ;; listed before.
  347.            (insert parent "\n")
  348.            (br-insert-classes (cdr parent-children-cons) 2))))
  349.           children-list))
  350.        (if arg (message "Computing children...Done"))
  351.        (goto-char (point-min))))))
  352.  
  353. (defun br-class-stats (&optional prompt)
  354.   "Display statistics summary for current class.
  355. Optional prefix arg PROMPT means prompt for class name."
  356.   (interactive "P")
  357.   (let ((class-name (if prompt (br-complete-class-name) (br-find-class-name))))
  358.     (if class-name
  359.     (message "Class %s:  Parents: %d; Children: %d"
  360.          class-name (length (br-get-parents class-name))
  361.          (length (br-get-children class-name)))
  362.       (error "No class name at point."))))
  363.  
  364. (defun br-cmd-help (key &optional full)
  365.   "Show first line of doc for OO-Browser KEY in minibuffer.
  366. With optional FULL, display full documentation for command."
  367.   (interactive "kOO-Browser key binding: \nP")
  368.   (let* ((cmd (let ((cmd (if (eq major-mode 'br-mode)
  369.                  (lookup-key br-mode-map key)
  370.                (key-binding key))))
  371.         (if (not (integerp cmd)) cmd)))
  372.      (doc (and cmd (documentation cmd)))
  373.      (end-line))
  374.     (if doc
  375.     (or full
  376.         (setq end-line (string-match "[\n]" doc)
  377.           doc (substitute-command-keys (substring doc 0 end-line))))
  378.       (setq doc (format "No documentation for {%s} %s" key (or cmd ""))))
  379.     (if (and cmd doc)
  380.     (if full
  381.         (progn (br-to-view-window)
  382.            (other-window -1)
  383.            (describe-function cmd))
  384.       (message doc)))))
  385.  
  386. (defun br-count ()
  387.   "Count number of entries visible in current listing buffer.
  388. Print text result in minibuffer when called interactively."
  389.   (interactive)
  390.   (let ((cnt (count-lines (point-min) (point-max))))
  391.     (if (interactive-p)
  392.     (message "%s contains %d entries." (buffer-name) cnt)
  393.       cnt)))
  394.  
  395. (defun br-copyright ()
  396.   "Display browser copyright information in viewer window."
  397.   (interactive)
  398.   (br-file-to-viewer "BR-COPY"))
  399.  
  400. (defun br-delete (&optional prompt)
  401.   "Delete class from current Environment.
  402. Does not alter descendency relations.
  403. Optional prefix arg PROMPT means prompt for class name."
  404.   (interactive "P")
  405.   (let ((class (if prompt (br-complete-class-name) (br-find-class-name))))
  406.     (and class
  407.      (if (interactive-p)
  408.          (y-or-n-p (concat "Delete class " class " from Environment? "))
  409.        t)
  410.      (progn (br-real-delete-class class)
  411.         ;; Delete class name at point in listing window
  412.         (or prompt (let (buffer-read-only)
  413.                  (progn (beginning-of-line)
  414.                     (delete-region
  415.                      (point) (progn (forward-line 1)
  416.                             (point))))))
  417.         (message "Class " class " deleted.")))))
  418.  
  419. (defun br-descendants (&optional arg)
  420.   "Display descendant tree whose root is the current class.
  421. With optional prefix ARG, display all descendant trees whose roots are
  422. the classes in the current listing."
  423.   (interactive "P")
  424.   (let ((parent-list
  425.      (if arg
  426.          (br-this-level-classes)
  427.        (list (br-find-class-name)))))
  428.     (cond ((delq nil (mapcar
  429.               (function (lambda (parent)
  430.                   (br-get-children parent)))
  431.               parent-list))
  432.        (if arg (message "Computing descendants..."))
  433.        (br-add-level-hist)
  434.        (br-next-buffer)
  435.        (let (buffer-read-only)
  436.          (br-descendant-trees parent-list))
  437.        (goto-char (point-min))
  438.        (if arg (message "Computing descendants...Done")))
  439.       (t
  440.        (message "No descendants.") (beep)))))
  441.  
  442. (defun br-edit-entry (&optional prompt)
  443.   "Edits source for any browser listing entry, such as a class or a feature.
  444. Optional prefix arg PROMPT means prompt for entry name."
  445.   (interactive "P")
  446.   (let ((entry) (sig))
  447.     (if prompt
  448.     (cond ((and (setq entry (br-complete-entry))
  449.             (string-match br-feature-signature-regexp entry))
  450.            (if (setq sig (car (br-feature-signature-and-file entry)))
  451.            (br-feature nil nil sig)
  452.          (error "(br-feature-signature-and-file): Couldn't find match for: '%s'" entry)))
  453.           (entry  ;; class name
  454.         (br-edit nil entry))
  455.           (t (error "(br-complete-entry): Exited without selecting a match")))
  456.       (cond ((br-find-feature-entry)
  457.          (br-feature))
  458.         ((and (setq entry (br-find-class-name))
  459.           (br-class-in-table-p entry))
  460.          (br-edit nil entry))
  461.         (t (error "(OO-Browser): No entry for current line in current Environment"))))))
  462.  
  463. (defun br-edit (&optional prompt class)
  464.   "Edit a class in the viewer window.
  465. Select viewer window.  With optional prefix arg PROMPT, prompt for class
  466. name.  Optional CLASS is the one to edit."
  467.   (interactive "P")
  468.   (or br-editor-cmd
  469.       (br-in-view-window-p)
  470.       (setq *br-prev-listing-window* (selected-window)))
  471.   (br-view prompt t class))
  472.  
  473. (defun br-edit-ext (editor-cmd file)
  474.   "Invoke a non-standard EDITOR-CMD on FILE.
  475. See also 'br-editor-cmd'."
  476.   (interactive "fFile to edit: ")
  477.   (or editor-cmd (setq editor-cmd br-editor-cmd))
  478.   (if (not (stringp editor-cmd)) ;; must be a Lisp function that takes a
  479.       ;; single, file arg
  480.       (funcall editor-cmd file)
  481.     (setq delete-exited-processes t)
  482.     (let ((proc)
  483.       (name (concat br-ed-name br-ed-num))
  484.       )
  485.       (setq br-ed-num (1+ br-ed-num)
  486.         proc (br-edit-ext-start editor-cmd name file))
  487.       (if proc
  488.       (process-kill-without-query proc)
  489.     (beep)
  490.     (message "(OO-Browser):  Could not start external edit process: %s"
  491.          editor-cmd)))))
  492.  
  493. (defun br-editor-kill ()
  494.   "Kill all current external editor sub-processes."
  495.   (interactive)
  496.   (if (br-kill-process-group br-ed-name br-ed-num "external editors")
  497.       (setq br-ed-num 0)))
  498.  
  499. (defun br-entry-info ()
  500.   "Display attributes of the current entry in the viewer window."
  501.   (interactive)
  502.   (if (fboundp 'br-insert-class-info)
  503.       (let ((class-name (br-find-class-name)))
  504.     (if class-name
  505.         (progn
  506.           (message "Building '%s' class info..." class-name)
  507.           (sit-for 2)
  508.           (br-store-class-info class-name)
  509.           (message "Building '%s' class info...Done" class-name)
  510.           (br-funcall-in-view-window
  511.            (concat br-buffer-prefix-info "Info")
  512.            'br-insert-class-info))
  513.       (error "Move point to a class name line.")))
  514.     (beep)
  515.     (message "No class information function for this language.")))
  516.  
  517. (defun br-exit-level (arg)
  518.   "Return to prefix ARGth previous inheritance level listing.
  519. The command is ignored with ARG < 1."
  520.   (interactive "p")
  521.   (setq arg (or arg 1))
  522.   (let ((prev-wind-buf-line))
  523.     (if (null *br-level-hist*)
  524.     (and (> arg 0)
  525.          (message "No previous level to which to exit.")
  526.          (beep))
  527.       (while (and (> arg 0) *br-level-hist*)
  528.     (br-next-buffer (br-listing-window-num) br-buffer-prefix-blank)
  529.     (setq prev-wind-buf-line (car *br-level-hist*)
  530.           *br-level-hist* (cdr *br-level-hist*)
  531.           arg (1- arg))
  532.     (select-window (car prev-wind-buf-line))
  533.     (switch-to-buffer (car (cdr prev-wind-buf-line))))
  534.       (widen)
  535.       ;; Position window lines exactly as before.
  536.       (recenter (car (cdr (cdr prev-wind-buf-line)))))))
  537.  
  538. (defun br-feature (&optional arg view-only ftr-sig)
  539.   "Edit a feature in the viewer window.  Select viewer window.
  540. With optional prefix ARG, prompt for feature name.
  541. Optional VIEW-ONLY non-nil means view rather than edit feature.
  542. Optional FTR-SIG is signature of feature to edit."
  543.   (interactive "P")
  544.   (or ftr-sig
  545.       (setq ftr-sig (if arg
  546.             (br-feature-complete 'must-match)
  547.               ;; Get current feature signature
  548.               (br-feature-get-signature))))
  549.   (if (null ftr-sig)
  550.       (error "(br-feature): No definition for this entry")
  551.     (br-to-view-window)
  552.     (if (br-feature-found-p (br-feature-file ftr-sig) ftr-sig)
  553.     (if view-only
  554.         (progn (setq buffer-read-only t)
  555.            (br-to-from-viewer))
  556.       (if (file-writable-p (buffer-file-name))
  557.           (setq buffer-read-only nil)))
  558.       ;; Feature not found.  Return to original window and signal an error.
  559.       (br-to-from-viewer)
  560.       (error "(br-feature): Can't find definition of: '%s'" ftr-sig))))
  561.  
  562. (defun br-features (arg)
  563.   "Display features/elements of the current class (prefix ARG = 1) or of the current listing if ARG is other than 0 or 1.
  564.  
  565. With ARG = 0, the value of the variable, 'br-inherited-features-flag', is
  566. toggled and no other action is taken.
  567.  
  568. If 'br-inherited-features-flag' is t, all features of each class are shown.
  569. If nil, only lexically included features are shown and if the features of a
  570. single class are requested and none are defined, the class definition is
  571. displayed so that its feature declarations may be browsed."
  572.   (interactive "p")
  573.   (cond ((and (integerp arg) (= arg 0))
  574.      (setq br-inherited-features-flag
  575.            (not br-inherited-features-flag))
  576.      (message "Inherited features/elements will %sbe shown."
  577.           (if br-inherited-features-flag "" "not ")))
  578.     (br-inherited-features-flag
  579.      (br-inherited-features arg))
  580.     (t (br-lexical-features arg))))
  581.  
  582. (defun br-find (element)
  583.   "Interactively complete class or ELEMENT name and jump to its definition.
  584. Return ELEMENT or signal an error."
  585.   (interactive (list (br-complete-entry)))
  586.   (if (and element
  587.        (progn
  588.          (if (not (br-in-view-window-p)) (br-to-from-viewer))
  589.          (if (string-match br-feature-signature-regexp element)
  590.          (br-find-feature element)
  591.            (br-find-class element))))
  592.       element
  593.     (error "(OO-Browser): '%s' definition not found." element)))
  594.  
  595. (defun br-help (&optional file)
  596.   "Display browser operation help information in viewer window."
  597.   (interactive)
  598.   (or file (setq file "br-help"))
  599.   (br-file-to-viewer file)
  600.   (save-window-excursion
  601.     (br-to-view-window)
  602.     (br-mode)
  603.     (use-local-map nil))
  604.   (message ""))
  605.  
  606. (defun br-help-ms ()
  607.   "Display browser mouse usage help information in viewer window."
  608.   (interactive)
  609.   (br-help "br-help-ms"))
  610.  
  611. (defun br-implementors (&optional arg)
  612.   "Display hierarchy of classes that define current element.
  613. Ignore inherited elements.  With optional prefix ARG, display implementors of
  614. all elements in the current listing."
  615.   (interactive "P")
  616.   (let
  617.       ((child-level (br-buffer-level))
  618.        (ftr-list (if arg (br-set-of-strings
  619.               (sort (br-this-level-features) 'string-lessp))
  620.            ;; Need this check to avoid trying to find implementors of
  621.            ;; a class which happens to have an attached element tag,
  622.            ;; e.g. in an implementors listing buffer.
  623.            (save-excursion
  624.              (beginning-of-line)
  625.              (skip-chars-forward " \t")
  626.              (if (looking-at br-feature-entry)
  627.              (list (br-find-feature-entry)))))))
  628.     (if (or (null ftr-list) (null (car ftr-list)))
  629.     (error
  630.       "(OO-Browser):  'br-implementors' must be applied to a feature.")
  631.       (message "Computing implementors...")
  632.       (br-add-level-hist)
  633.       (br-next-listing-window -1)
  634.       (br-next-buffer (concat "p" child-level))
  635.       (let ((buffer-read-only) (implementor-tags) (classes)
  636.         start)
  637.     (widen)
  638.     (erase-buffer)
  639.     (mapcar (function
  640.           (lambda (ftr-entry)
  641.             (setq implementor-tags
  642.               (sort
  643.                (br-feature-implementors
  644.                 (br-feature-name ftr-entry))
  645.                'string-lessp)
  646.               classes (mapcar 'br-feature-tag-class
  647.                       implementor-tags))
  648.             (insert ftr-entry "\n")
  649.             (setq start (point))
  650.             (br-insert-classes classes 4)
  651.             (save-excursion
  652.               (goto-char start)
  653.               (br-feature-put-signatures implementor-tags))))
  654.         ftr-list))
  655.       (goto-char 1)
  656.       (message "Computing implementors...Done"))))
  657.  
  658. (defun br-inherited-features (arg)
  659.   "Display class features, including those from ancestors.
  660. With optional prefix ARG, display features of all classes in the current
  661. listing."
  662.   (interactive "p")
  663.   (let ((br-ancestor-function
  664.      (function
  665.       (lambda (class repeated-class indent)
  666.         (if repeated-class
  667.         nil
  668.           (br-insert-features (br-list-features class indent) indent))))))
  669.     (br-ancestors arg t)))
  670.  
  671. (defun br-kill ()
  672.   "Kill buffer in viewer window and redisplay help text."
  673.   (interactive)
  674.   (br-do-in-view-window '(progn (kill-buffer nil) (br-help))))
  675.  
  676. (defun br-lexical-features (arg)
  677.   "Display class features lexically defined within current class.
  678. With numeric prefix ARG, display features of all classes in the current
  679. listing.
  680.  
  681. If the features of a single class are requested and there are no feature
  682. definitions for the class, display the class definition so that its feature
  683. declarations may be browsed."
  684.   (interactive "p")
  685.   (let ((has-features)
  686.     class-list features class-and-features)
  687.     (setq class-list (cond ((and (integerp arg) (/= arg 1))
  688.                 (message "Computing class features...")
  689.                 (br-this-level-classes))
  690.                (t 
  691.                 (list (br-find-class-name))))
  692.       features
  693.       (delq nil (mapcar
  694.              (function
  695.               (lambda (class)
  696.             (setq class-and-features (br-list-features class)
  697.                   has-features (or has-features
  698.                            class-and-features))
  699.             (cons class class-and-features)))
  700.              class-list)))
  701.     (cond ((not class-list)
  702.        (beep)
  703.        (message "(OO-Browser):  Apply 'br-features' to a class."))
  704.       ((not has-features)
  705.        (if (and (= (length class-list) 1)
  706.             (br-class-path (car class-list)))
  707.            (if (br-view nil nil (car class-list))
  708.            (message
  709.             "No feature definitions, browse declarations instead."))
  710.          (message "No class features.") (beep)))
  711.       (t
  712.        (br-add-level-hist)
  713.        (br-next-buffer nil)
  714.        (let (buffer-read-only done-set class)
  715.          (mapcar
  716.           (function
  717.            (lambda (class-and-features)
  718.          (setq class (car class-and-features))
  719.          (if (not (br-set-cons done-set class))
  720.              (insert class " ...\n")
  721.            ;; Class successfully added to set, so it has not been
  722.            ;; listed before.
  723.            (insert class "\n")
  724.            (br-insert-features (cdr class-and-features) 2))))
  725.           features)
  726.          (message "Computing class features...Done")
  727.          (goto-char (point-min)))))))
  728.  
  729. (defun br-lib-rebuild ()
  730.   "Rescan Library components of the current Environment."
  731.   (interactive)
  732.   (if (call-interactively 'br-build-lib-htable)
  733.       (br-top-classes t)))
  734.  
  735. (defun br-lib-top-classes (&optional arg)
  736.   "Display list of top level Library classes.
  737. With prefix ARG, display all Library classes."
  738.   (interactive "P")
  739.   (and (or (not (interactive-p))
  740.        (br-in-top-buffer-p)
  741.        (y-or-n-p "Exit to top-level class listing buffer? "))
  742.        (cond (arg
  743.           (br-show-top-classes
  744.            (function (lambda () (br-all-classes "lib")))
  745.            'uniq)
  746.           (message "Listing of all Library classes"))
  747.          (t
  748.           (br-show-top-classes 'br-get-lib-top-classes 'uniq)
  749.           (message "Listing of top-level Library classes")))
  750.        (setq *br-level-hist* nil)))
  751.  
  752. (defun br-match (&optional expr arg again matched)
  753.   "Show all class names in current Environment that contain optional EXPR.
  754. Nil value of EXPR means prompt for a value.  With optional prefix ARG, EXPR
  755. is treated as a string.  By default, it is treated as a regular expresion.
  756. AGAIN non-nil shows the number of classes MATCHED from the last search,
  757. allowing repeated narrowing of the search set.  Empty EXPR when AGAIN is nil
  758. matches to all classes in the Environment."
  759.   (interactive (list nil current-prefix-arg))
  760.   (or expr (setq expr (read-string
  761.                (concat (if again (format "(%s matches)  " matched))
  762.                    (if arg
  763.                    "Find Environment class string matches"
  764.                  "Find Environment class regular expression matches")
  765.                    (if again " (RTN to end): " ": ")))))
  766.   (if (and again (equal expr ""))
  767.       nil
  768.     (let* ((match-expr (if arg (regexp-quote expr) expr))
  769.        (classes
  770.         (delq nil (mapcar
  771.                (function
  772.             (lambda (cl)
  773.               (if (string-match match-expr cl) cl)))
  774.                (if again
  775.                (sort (br-this-level-classes) 'string-lessp)
  776.              (br-all-classes))))))
  777.       (setq classes (br-class-list-filter classes))
  778.       (if classes
  779.       (progn (let (buffer-read-only)
  780.            (br-feature-clear-signatures)
  781.            (erase-buffer)
  782.            (br-insert-classes classes 0))
  783.          (goto-char (point-min))
  784.          (br-match nil arg t (br-count)))
  785.     (beep)
  786.     (message "No matches for \"%s\"." expr)))))
  787.  
  788. (defun br-match-entries (&optional expr arg again matched)
  789.   "Show all entries in current listing that contain optional EXPR.
  790. Nil value of EXPR means prompt for a value.  With optional prefix ARG, EXPR
  791. is treated as a string.  By default, it is treated as a regular expresion.
  792. AGAIN non-nil means show the number of entries MATCHED from last search,
  793. allowing repeated narrowing of the search set.  Empty EXPR when AGAIN is nil
  794. matches to all entries in the listing."
  795.   (interactive (list nil current-prefix-arg))
  796.   (or expr (setq expr (read-string
  797.             (concat (if again (format "(%s matches)  " matched))
  798.                 (if arg
  799.                     "Find string matches in listing"
  800.                   "Find regular expression matches in listing")
  801.                 (if again " (RTN to end): " ": ")))))
  802.   (if (and again (equal expr ""))
  803.       nil
  804.     (let* ((match-expr (if arg (regexp-quote expr) expr))
  805.        (buffer-read-only))
  806.       (goto-char (point-min))
  807.       (if (not (re-search-forward match-expr nil t))
  808.       (progn (beep)
  809.          (message "No matches for \"%s\"." expr))
  810.     (goto-char (point-min))
  811.     (delete-non-matching-lines match-expr)
  812.     (goto-char (point-min))
  813.     (br-match-entries nil arg t (br-count))))))
  814.  
  815. (defun br-next-entry (arg)
  816.   "Move point vertically down prefix ARG number of lines in listing buffer."
  817.   (interactive "p")
  818.   (let ((end))
  819.     (setq end (= (forward-line arg) arg))
  820.     (and (looking-at "^$") (forward-line -1) (setq end t))
  821.     (and end (message "No next entry.") (beep))))
  822.  
  823. (defun br-order (arg)
  824.   "Order current browser listing window entries.
  825. With prefix ARG other than 1 (the default), don't remove leading space from
  826. entry lines before ordering.  Negative ARG means order in descending Ascii
  827. sequence, otherwise order in ascending sequence."
  828.   (interactive "p")
  829.   (setq arg (or arg 1))
  830.   (message "Ordering entries...")
  831.   (let ((buffer-read-only)
  832.     sort-args)
  833.     (and (= arg 1) (progn (goto-char (point-min))
  834.               (while (re-search-forward "^[ \t]+" nil t)
  835.                 (replace-match ""))))
  836.     (if (string-match "^19\\." emacs-version)
  837.     (progn
  838.       ;; Emacs 19: This slower than calling an external sort but it
  839.       ;; maintains the element tags in a listing, allowing further browsing
  840.       ;; from this buffer.
  841.       (sort-lines (< arg 0) (point-min) (point-max))
  842.       ;; Move [default] classes to the end of the sorted list.
  843.       (goto-char (point-min))
  844.       (if (re-search-forward "^[ \t]*\\[" nil t)
  845.           (let (start end)
  846.         (beginning-of-line)
  847.         (setq start (point))
  848.         (goto-char (point-max))
  849.         (re-search-backward "^[ \t]*\\[" nil t)
  850.         (forward-line 1)
  851.         (setq end (point))
  852.         (goto-char (point-max))
  853.         (append-to-buffer (current-buffer) start end)
  854.         (delete-region start end))))
  855.       ;;
  856.       ;; Emacs 18: We can't maintain the buffer tags, so we just use a fast
  857.       ;; external sort.
  858.       (setq sort-args (list (point-min) (point-max) "sort" t t nil)
  859.         sort-args (if (< arg 0)
  860.               (if (stringp br-sort-options)
  861.                   (nconc sort-args (list "-r" br-sort-options))
  862.                 (nconc sort-args (list "-r")))
  863.             (if (stringp br-sort-options)
  864.                 (nconc sort-args (list br-sort-options))
  865.               sort-args)))
  866.       (apply 'call-process-region sort-args)))
  867.   (goto-char (point-min))
  868.   (message "Ordering entries...Done"))
  869.  
  870. (defun br-parents (&optional arg)
  871.   "Display parents of current class.
  872. With optional prefix ARG, display parents of all the classes in the current
  873. listing."
  874.   (interactive "P")
  875.   (let ((class-list (cond (arg
  876.                (message "Computing parents...")
  877.                (br-this-level-classes))
  878.               (t
  879.                (list (br-find-class-name)))))
  880.     (has-parents)
  881.     parents parents-list)
  882.     (setq parents-list
  883.       (delq nil (mapcar (function
  884.                  (lambda (class)
  885.                    (setq parents (br-get-parents class)
  886.                      has-parents (or has-parents parents))
  887.                    (cons class parents)))
  888.                 class-list)))
  889.     (cond ((not parents-list)
  890.        (beep)
  891.        (message "(OO-Browser):  Apply 'br-parents' to a class."))
  892.       ((not has-parents)
  893.        (message "No parents.") (beep))
  894.       (t
  895.        (let ((child-level (br-buffer-level)))
  896.          (br-add-level-hist)
  897.          (br-next-listing-window -1)
  898.          (br-next-buffer (concat "p" child-level)))
  899.        (let (buffer-read-only done-set class)
  900.          (mapcar
  901.           (function
  902.            (lambda (class-parents-cons)
  903.          (setq class (car class-parents-cons))
  904.          (if (not (br-set-cons done-set class))
  905.              (insert class " ...\n")
  906.            ;; Class successfully added to set, so it has not been
  907.            ;; listed before.
  908.            (insert class "\n")
  909.            (br-insert-classes (cdr class-parents-cons) 2))))
  910.           parents-list))
  911.        (if arg (message "Computing parents...Done"))
  912.        (goto-char (point-min))))))
  913.  
  914. (defun br-prev-entry (arg)
  915.   "Move point vertically up prefix ARG number of lines in listing buffer."
  916.   (interactive "p")
  917.   (setq arg (- arg))
  918.   (and (= (forward-line arg) arg)
  919.        (message "No previous entry.")
  920.        (beep)))
  921.  
  922. (defun br-protocols (&optional arg)
  923.   "Display protocols to which the current class conforms.
  924. This does not include any protocols which the class inherits from its
  925. ancestors but it does include protocols which conform to other protocols.
  926. With optional prefix ARG, display protocols of all classes in the current
  927. listing."
  928.   (interactive "P")
  929.   (let ((has-protocols)
  930.     class-list protocols class-and-protocols)
  931.     (setq class-list (cond (arg
  932.                 (message "Computing class protocols...")
  933.                 (br-this-level-classes))
  934.                (t 
  935.                 (list (br-find-class-name)))))
  936.     (if (and (= (length class-list) 1)
  937.          (br-protocol-entry-p))
  938.     ;; If on a protocol entry, display its definition.
  939.     (br-view-protocol (car class-list))
  940.       ;; Otherwise, list protocols for all elements of class-list.
  941.       (setq protocols
  942.         (delq nil (mapcar
  943.                (function
  944.             (lambda (class)
  945.               (setq class-and-protocols (br-list-protocols class)
  946.                 has-protocols (or has-protocols
  947.                           class-and-protocols))
  948.               (cons class class-and-protocols)))
  949.                class-list)))
  950.       (cond ((not class-list)
  951.          (beep)
  952.          (message "(OO-Browser):  Apply 'br-protocols' to a class."))
  953.         ((not has-protocols)
  954.          (message "No class protocols.") (beep))
  955.         (t
  956.          (br-add-level-hist)
  957.          (br-next-buffer nil)
  958.          (let (buffer-read-only done-set class)
  959.            (mapcar
  960.         (function
  961.          (lambda (class-and-protocols)
  962.            (setq class (car class-and-protocols))
  963.            (if (not (br-set-cons done-set class))
  964.                (insert class " ...\n")
  965.              ;; Class successfully added to set, so it has not been
  966.              ;; listed before.
  967.              (insert class "\n")
  968.              (br-insert-features (cdr class-and-protocols) 2))))
  969.         protocols))
  970.          (message "Computing class protocols...Done")
  971.          (goto-char (point-min)))))))
  972.  
  973. (defun br-quit (&optional arg)
  974.   "Quit browser.
  975. With optional prefix ARG, delete window configurations and listing
  976. buffers associated with the browser."
  977.   (interactive "P")
  978.   (if (not (br-in-browser))
  979.       nil
  980.     (if (null arg)
  981.     (setq *br-save-wconfig* (current-window-configuration))
  982.       (if (featurep 'br-tree) (br-tree-kill))
  983.       (br-viewer-kill)
  984.       ;; Too dangerous to include (br-editor-kill) here.
  985.       ;; The user can invoke it manually if desired.
  986.       )
  987.     (and *br-prev-wconfig* (set-window-configuration *br-prev-wconfig*))
  988.     (br-interrupt arg)))
  989.  
  990. (defun br-refresh ()
  991.   "Restore OO-Browser to its state upon startup."
  992.   (interactive)
  993.   (br-window-setup)
  994.   (br-top-classes t)
  995.   (br-help))
  996.  
  997. (defun br-sys-rebuild ()
  998.   "Rescan System components of the current Environment."
  999.   (interactive)
  1000.   (if (call-interactively 'br-build-sys-htable)
  1001.       (br-top-classes t)))
  1002.  
  1003. (defun br-sys-top-classes (&optional arg)
  1004.   "Display list of top level System classes.
  1005. With prefix ARG, display all System classes."
  1006.   (interactive "P")
  1007.   (and (or (not (interactive-p))
  1008.        (br-in-top-buffer-p)
  1009.        (y-or-n-p "Exit to top-level class listing buffer? "))
  1010.        (cond (arg
  1011.           (br-show-top-classes
  1012.            (function (lambda () (br-all-classes "sys")))
  1013.            'uniq)
  1014.           (message "Listing of all System classes"))
  1015.          (t
  1016.           (br-show-top-classes 'br-get-sys-top-classes 'uniq)
  1017.           (message "Listing of top-level System classes")))
  1018.        (setq *br-level-hist* nil)))
  1019.  
  1020. ;;;###autoload
  1021. (defun br-to-from-viewer ()
  1022.   "Move point to viewer window or back to last recorded listing window."
  1023.   (interactive)
  1024.   (if (br-in-view-window-p)
  1025.       (progn (if *br-prev-listing-window*
  1026.          (select-window *br-prev-listing-window*)
  1027.            (other-window 1))
  1028.          (setq *br-prev-listing-window* nil))
  1029.     (br-to-view-window)))
  1030.  
  1031. (defun br-toggle-c-tags ()
  1032.   "Toggle the value of the 'br-c-tags-flag' flag."
  1033.   (interactive)
  1034.   (setq br-c-tags-flag (not br-c-tags-flag))
  1035.   (message "C constructs will %sbe added to C-based language Environments."
  1036.        (if br-c-tags-flag "" "not ")))
  1037.  
  1038. (defun br-toggle-keep-viewed ()
  1039.   "Toggle the value of the 'br-keep-viewed-classes' flag."
  1040.   (interactive)
  1041.   (setq br-keep-viewed-classes (not br-keep-viewed-classes))
  1042.   (message "Viewed classes will no%s be kept after use."
  1043.        (if br-keep-viewed-classes "w" "t")))
  1044.  
  1045. (defun br-top-classes (&optional arg)
  1046.   "Display list of top level classes.
  1047. With prefix ARG, display all Environment classes."
  1048.   (interactive "P")
  1049.   (and (or (not (interactive-p))
  1050.        (br-in-top-buffer-p)
  1051.        (y-or-n-p "Exit to top-level class listing buffer? "))
  1052.        (cond (arg
  1053.           (br-show-top-classes 'br-all-classes 'uniq)
  1054.           (message "Listing of all Environment classes"))
  1055.          (t
  1056.           (br-show-top-classes 'br-get-top-classes 'uniq)
  1057.           (message "Listing of top-level classes")))
  1058.        (setq *br-level-hist* nil)))
  1059.  
  1060. (defun br-unique ()
  1061.   "Eliminate adjacent duplicate entry names from the current listing window.
  1062. If two adjacent entries look the same one is eliminated, even if they refer
  1063. to different class elements."
  1064.   (interactive)
  1065.   (let ((buffer-read-only)
  1066.     (again t)
  1067.     first second)
  1068.     (goto-char (point-min))
  1069.     (setq first (br-feature-current))
  1070.     (while again
  1071.       (setq again (= (forward-line 1) 0)
  1072.         second (br-feature-current))
  1073.       (if (not (string-equal first second))
  1074.       (setq first second)
  1075.     (beginning-of-line)
  1076.     (delete-region (point) (progn (forward-line 1) (point)))
  1077.     ;; back up to first line again
  1078.     (forward-line -1)))
  1079.     (goto-char (point-min))))
  1080.  
  1081. (defun br-version ()
  1082.   "Display browser version number and credits."
  1083.   (interactive)
  1084.   (br-file-to-viewer "BR-VERSION")
  1085.   (br-funcall-in-view-window
  1086.    (concat br-buffer-prefix-info "Help")
  1087.    (function (lambda ()
  1088.            (if (re-search-forward "<VERSION>" nil t)
  1089.            (replace-match br-version t t))
  1090.            (center-line)
  1091.            (set-buffer-modified-p nil)))
  1092.    t))
  1093.  
  1094. (defun br-view-entry (&optional prompt)
  1095.   "Displays source for any browser listing entry.
  1096. Optional prefix arg PROMPT means prompt for entry name."
  1097.   (interactive "P")
  1098.   (let ((entry) (sig))
  1099.     (if prompt
  1100.     (cond ((and (setq entry (br-complete-entry))
  1101.             (string-match br-feature-signature-regexp entry))
  1102.            (if (setq sig (car (br-feature-signature-and-file entry)))
  1103.            (br-feature nil 'view sig)
  1104.          (error "(br-feature-signature-and-file): Couldn't find match for: '%s'" entry)))
  1105.           (entry ;; class name
  1106.            (br-view nil nil entry))
  1107.           (t (error "(br-complete-entry): Exited without selecting a match")))
  1108.       (cond ((br-find-feature-entry)
  1109.          (br-feature nil 'view))
  1110.         ((and (setq entry (br-find-class-name))
  1111.           (br-class-in-table-p entry))
  1112.          (br-view nil nil entry))
  1113.         (t (error "(OO-Browser): Entry may be referenced but not defined in the Environment."))))))
  1114.  
  1115. (defun br-view (&optional prompt writable class)
  1116.   "Displays class file in viewer window.
  1117. Optional prefix arg PROMPT means prompt for class name.  Non-nil WRITABLE means
  1118. allow editing, otherwise display in read-only mode.  Non-nil CLASS is class to
  1119. display.
  1120.  
  1121. Return t if class is displayed or sent to an external viewer, else nil."
  1122.   (interactive "P")
  1123.   (or class (setq class (if prompt (br-complete-class-name)
  1124.               (br-find-class-name))))
  1125.   (cond ((null class)
  1126.      (beep)
  1127.      (message "(OO-Browser):  Select a class to view.")
  1128.      nil)
  1129.     ((not (br-class-defined-p class)) nil)
  1130.     ((and hyperb:window-system
  1131.           (cond ((and br-editor-cmd writable)
  1132.             (br-edit-ext br-editor-cmd (br-class-path class))
  1133.             t)
  1134.            (br-viewer-cmd
  1135.             (br-view-ext br-viewer-cmd (br-class-path class))
  1136.             t))))
  1137.     ;; Support custom Lisp-based edit/view cmds on any display type
  1138.     ((and br-editor-cmd writable (not (stringp br-editor-cmd)))
  1139.      (br-edit-ext br-editor-cmd (br-class-path class))
  1140.      t)
  1141.     ((and br-viewer-cmd (not (stringp br-viewer-cmd)))
  1142.      (br-view-ext br-viewer-cmd (br-class-path class))
  1143.      t)
  1144.     (t (let ((owind (selected-window)))
  1145.          (unwind-protect
  1146.          (progn (br-to-view-window)
  1147.             (if (and (not br-keep-viewed-classes) buffer-read-only
  1148.                  (null (buffer-modified-p)))
  1149.                 (kill-buffer (current-buffer)))
  1150.             (if (br-find-class class (not writable))
  1151.                 (progn (br-major-mode)
  1152.                    (if writable
  1153.                        (if (file-writable-p (buffer-file-name))
  1154.                        (setq buffer-read-only nil))
  1155.                      (setq buffer-read-only t)
  1156.                      (select-window owind))
  1157.                    t)))
  1158.            (or writable (select-window owind)))))))
  1159.  
  1160. (defun br-view-ext (viewer-cmd file)
  1161.   "Invoke a non-standard VIEWER-CMD on FILE.
  1162. See also 'br-viewer-cmd'."
  1163.   (interactive "fFile to view: ")
  1164.   (or viewer-cmd (setq viewer-cmd br-viewer-cmd))
  1165.   (if (not (stringp viewer-cmd)) ;; must be a Lisp function that takes a
  1166.       ;; single, file arg
  1167.       (funcall viewer-cmd file)
  1168.     (setq delete-exited-processes t)
  1169.     (let ((proc)
  1170.       (name (concat br-vw-name br-vw-num))
  1171.       )
  1172.       (setq br-vw-num (1+ br-vw-num)
  1173.         proc (br-view-ext-start viewer-cmd name file))
  1174.       (if proc
  1175.       (process-kill-without-query proc)
  1176.     (beep)
  1177.     (message "(OO-Browser):  Could not start external view process: %s"
  1178.           viewer-cmd)))))
  1179.  
  1180. (defun br-view-full-frame ()
  1181.   "Delete all windows in the selected frame except for the viewer window."
  1182.   (interactive)
  1183.   (setq *br-save-wconfig* (current-window-configuration))
  1184.   (br-to-view-window)
  1185.   (let ((buf (current-buffer)))
  1186.     (br-interrupt)
  1187.     (delete-other-windows)
  1188.     (switch-to-buffer buf))
  1189.   (let* ((cmd (concat br-lang-prefix "browse"))
  1190.      (key (car (where-is-internal (intern-soft cmd)))))
  1191.     (message "Recall OO-Browser with: {%s}"
  1192.          (if key
  1193.          (key-description key)
  1194.            (concat (key-description
  1195.             (or (car (where-is-internal
  1196.                   'execute-extended-command))
  1197.                 "\M-x"))
  1198.                " " cmd)))))
  1199.  
  1200. (defun br-viewer-kill ()
  1201.   "Kill all current external viewer sub-processes."
  1202.   (interactive)
  1203.   (if (br-kill-process-group br-vw-name br-vw-num "external viewers")
  1204.       (setq br-vw-num 0)))
  1205.  
  1206. (defun br-viewer-scroll-down (&optional arg)
  1207.   "Scroll viewer window downward ARG lines or a windowful if no ARG."
  1208.   (interactive "P")
  1209.   (let ((owind (selected-window)))
  1210.     (unwind-protect
  1211.     (progn (br-to-view-window)
  1212.            (scroll-down arg))
  1213.       (select-window owind))))
  1214.  
  1215. (defun br-viewer-scroll-up (&optional arg)
  1216.   "Scroll viewer window upward ARG lines or a windowful if no ARG."
  1217.   (interactive "P")
  1218.   (let ((owind (selected-window)))
  1219.     (unwind-protect
  1220.     (progn (br-to-view-window)
  1221.            (scroll-up arg))
  1222.       (select-window owind))))
  1223.  
  1224. (defun br-where (&optional prompt)
  1225.   "Display in minibuffer and return full path of a browser listing entry.
  1226. Optional prefix arg PROMPT means prompt for entry name."
  1227.   (interactive "P")
  1228.   (let ((entry) (path))
  1229.     (if prompt
  1230.     (cond ((and (setq entry (br-complete-entry))
  1231.             (string-match br-feature-signature-regexp entry))
  1232.            (setq path (cdr (br-feature-signature-and-file entry))))
  1233.           (entry ;; class name
  1234.            (setq path (br-class-defined-p entry)))
  1235.           (t (error "(br-complete-entry): Exited without selecting a match")))
  1236.       (cond ((setq entry (br-find-feature-entry))
  1237.          (setq path (cdr (br-feature-signature-and-file entry))))
  1238.         ((setq entry (br-find-class-name))
  1239.          (or (setq path (br-class-path entry))
  1240.          (error "(OO-Browser): No path for this class in current Environment")))
  1241.         (t (error "(OO-Browser): No entry for current line in current Environment"))))
  1242.     (and path (message (concat entry ":  " "\"" path "\""))
  1243.      path)))
  1244.  
  1245. (defun br-write-buffer (file)
  1246.   "Write narrowed portion of current browser buffer to a file."
  1247.   (interactive "FFile to write buffer to: ")
  1248.   (write-region (point-min) (point-max) file))
  1249.  
  1250. ;;; ************************************************************************
  1251. ;;; Private functions
  1252. ;;; ************************************************************************
  1253.  
  1254. (defun br-add-level-hist ()
  1255.   ;; Even though this next line looks useless, it cures a problem with
  1256.   ;; window buffer correspondences when the OO-Browser is started, so don't
  1257.   ;; remove it.
  1258.   (set-buffer (window-buffer (selected-window)))
  1259.   (setq *br-level-hist*
  1260.     (cons (list (selected-window) (buffer-name) (br-wind-line-at-point))
  1261.           *br-level-hist*)))
  1262.  
  1263. (defun br-ancestor-roots (class-list)
  1264.   "Return list of CLASS-LIST's unique ancestors which do not inherit from any other class.
  1265. This list may include elements from CLASS-LIST itself."
  1266.   (let ((rtn) (parents) func)
  1267.     (setq func (function
  1268.         (lambda (class-list)
  1269.           (mapcar
  1270.            (function
  1271.             (lambda (class)
  1272.               (if (not (setq parents (br-get-parents class)))
  1273.               (setq rtn (cons class rtn))
  1274.             (funcall func parents))))
  1275.            class-list))))
  1276.     (funcall func class-list)
  1277.     (br-set-of-strings (sort rtn 'string-lessp))))
  1278.  
  1279. (defun br-ancestor-trees-inverted (class-list &optional depth offset)
  1280.   "Insert ancestor trees starting with classes from CLASS-LIST.
  1281. Ancestor trees are inverted, i.e. parents appear below children, not above.
  1282. Indent each class in CLASS-LIST by optional DEPTH spaces (default is 0 in
  1283. order to ensure proper initialization).  Offset each child level by optional
  1284. OFFSET spaces from its parent (which must be greater than zero, default 2)."
  1285.   (or offset (setq offset 2))
  1286.   (or depth (setq depth 0))
  1287.   (if (= depth 0) (setq br-tmp-class-set nil))
  1288.   (let ((prev-expansion-str " ...")
  1289.     parents expand-subtree)
  1290.     (mapcar
  1291.       (function
  1292.     (lambda (class)
  1293.       (setq expand-subtree (br-set-cons br-tmp-class-set class)
  1294.         parents (if expand-subtree (br-get-parents class)))
  1295.       (indent-to depth)
  1296.       (insert class)
  1297.       (and (not expand-subtree) (br-has-children-p class)
  1298.            (insert prev-expansion-str))
  1299.       (insert "\n")
  1300.       (if br-ancestor-function
  1301.           (funcall br-ancestor-function
  1302.                class (not expand-subtree) (+ depth offset)))
  1303.       (if parents
  1304.           (br-ancestor-trees-inverted parents (+ depth offset) offset))))
  1305.       class-list))
  1306.   (if (= depth 0) (setq br-tmp-class-set nil)))
  1307.  
  1308. (defun br-ancestor-trees (class-list &optional depth offset)
  1309.   "Insert ancestor trees starting with classes from CLASS-LIST.
  1310. Ancestor trees are not inverted, parents appear above children as in other
  1311. browser listing windows.  Indent each class in CLASS-LIST by optional DEPTH
  1312. spaces (default is 0 in order to ensure proper initialization).  Offset each
  1313. child level by optional OFFSET spaces from its parent (which must be greater
  1314. than zero, default 2)."
  1315.   (or offset (setq offset 2))
  1316.   (or depth (setq depth 0 br-tmp-depth 0))
  1317.   (if (= depth 0) (setq br-tmp-class-set nil))
  1318.   (let ((prev-expansion-str " ...")
  1319.     parents expand-subtree)
  1320.     (mapcar (function
  1321.           (lambda (class)
  1322.         (setq expand-subtree (br-set-cons br-tmp-class-set class)
  1323.               parents (if expand-subtree (br-get-parents class)))
  1324.         (if parents
  1325.             (progn (setq br-tmp-depth
  1326.                  (max (+ depth offset) br-tmp-depth))
  1327.                (br-ancestor-trees
  1328.                 parents (+ depth offset) offset)))
  1329.         (indent-to (- br-tmp-depth depth))
  1330.         (insert class)
  1331.         (and (not expand-subtree) (br-has-parents-p class)
  1332.              (insert prev-expansion-str))
  1333.         (insert "\n")
  1334.         (if br-ancestor-function
  1335.             (funcall br-ancestor-function
  1336.                  class (not expand-subtree) (+ depth offset)))
  1337.         (if (= depth 0) (setq br-tmp-depth 0))))
  1338.         class-list))
  1339.   (if (= depth 0) (setq br-tmp-class-set nil)))
  1340.  
  1341. (defun br-browser-buffer-p (&optional buffer)
  1342.   "Returns t iff optional BUFFER or current buffer is an OO-Browser specific buffer."
  1343.   (equal 0 (string-match (concat br-buffer-prefix-inher
  1344.                  "\\|" br-buffer-prefix-categ
  1345.                  "\\|" br-buffer-prefix-blank
  1346.                  "\\|" br-buffer-prefix-info)
  1347.              (buffer-name buffer))))
  1348.  
  1349. (defun br-buffer-level ()
  1350.   "Returns current listing buffer level as a string."
  1351.   (let* ((name (buffer-name))
  1352.      (pos (string-match "-[p]*[0-9]+$" name)))
  1353.     (and pos (substring name (1+ pos)))))
  1354.  
  1355. (defun br-class-level ()
  1356.   "Returns current class hierarchy level as an integer.
  1357. 1 is the top level."
  1358.   (let* ((name (buffer-name))
  1359.      (pos (string-match "[0-9]" name)))
  1360.     (and pos (string-to-int (substring name pos)))))
  1361.  
  1362. (defun br-listing-window-num ()
  1363.   "Return listing window number, lefmost is 1, non-listing window = 0."
  1364.   (let ((wind (selected-window))
  1365.     (ctr 0))
  1366.     (br-to-view-window)
  1367.     (while (not (eq wind (selected-window)))
  1368.       (other-window 1)
  1369.       (setq ctr (1+ ctr)))
  1370.     ctr))
  1371.  
  1372. (defun br-cleanup ()
  1373.   "Cleanup and free browser Environment data structures."
  1374.   (setq br-lang-prefix nil
  1375.     br-sys-paths-htable nil
  1376.     br-lib-paths-htable nil
  1377.     br-paths-htable nil
  1378.     br-sys-parents-htable nil
  1379.     br-lib-parents-htable nil
  1380.     br-parents-htable nil
  1381.     br-children-htable nil
  1382.     br-lib-prev-search-dirs nil
  1383.     br-sys-prev-search-dirs nil
  1384.     ))
  1385.  
  1386. (defun br-clear ()
  1387.   "Re-initialize all browser listing buffer displays.
  1388. Leave point in browser top-level class listing buffer."
  1389.   (let ((n (max 1 (/ (frame-width) br-min-width-window))))
  1390.     (br-to-view-window)
  1391.     (other-window 1)
  1392.     (br-next-buffer 1)
  1393.     (while (> n 1)
  1394.       (setq n (1- n))
  1395.       (br-next-buffer nil br-buffer-prefix-blank))
  1396.     (br-to-view-window)
  1397.     (other-window 1)))
  1398.  
  1399. (defun br-descendant-trees (class-list &optional indent offset)
  1400.   "Insert descendant trees starting with classes from CLASS-LIST.
  1401. Indent each class in CLASS-LIST by optional INDENT spaces (default is 0 in
  1402. order to ensure proper initialization).  Offset each child level by optional
  1403. OFFSET spaces from its parent (which must be greater than zero, default 2)."
  1404.   (or indent (setq indent 0))
  1405.   (or offset (setq offset 2))
  1406.   (if (= indent 0) (setq br-tmp-class-set nil))
  1407.   (let ((prev-expansion-str " ...")
  1408.     children expand-subtree)
  1409.     (mapcar (function
  1410.           (lambda (class)
  1411.         (setq expand-subtree (br-set-cons br-tmp-class-set class)
  1412.               children (if expand-subtree (br-get-children class)))
  1413.         (indent-to indent)
  1414.         (insert class)
  1415.         (and (not expand-subtree) (br-has-children-p class)
  1416.              (insert prev-expansion-str))
  1417.         (insert "\n")
  1418.         (if children
  1419.             (br-descendant-trees children (+ indent offset) offset))))
  1420.         class-list))
  1421.   (if (= indent 0) (setq br-tmp-class-set nil)))
  1422.  
  1423. (defun br-display-buffer (suffix)
  1424.   "Displays browser buffer ending in SUFFIX in current window."
  1425.   (let ((buf (get-buffer (concat br-buffer-prefix suffix))))
  1426.     (if buf (progn (set-window-buffer (selected-window) buf)))
  1427.     buf))
  1428.  
  1429. (defun br-do-in-view-window (form)
  1430.   "Evaluate FORM in viewer window and then return to current window."
  1431.   (interactive)
  1432.   (let ((wind (selected-window)))
  1433.     (unwind-protect
  1434.     (progn (br-to-view-window)
  1435.            (eval form))
  1436.       (select-window wind))))
  1437.  
  1438. (defun br-edit-ext-start (editor-cmd name file)
  1439.   "Start an external viewer given by EDITOR-CMD using NAME applied to FILE."
  1440.   ;; Conditionalized code is necessary because of silly (start-process) calling
  1441.   ;; protocol.
  1442.   (cond (br-ed9
  1443.      (start-process name name editor-cmd br-ed1 br-ed2 br-ed3 br-ed4
  1444.             br-ed5 br-ed6 br-ed7 br-ed8 br-ed9 file))
  1445.     (br-ed8
  1446.      (start-process name name editor-cmd br-ed1 br-ed2 br-ed3 br-ed4
  1447.             br-ed5 br-ed6 br-ed7 br-ed8 file))
  1448.     (br-ed7
  1449.      (start-process name name editor-cmd br-ed1 br-ed2 br-ed3 br-ed4
  1450.             br-ed5 br-ed6 br-ed7 file))
  1451.     (br-ed6
  1452.      (start-process name name editor-cmd br-ed1 br-ed2 br-ed3 br-ed4
  1453.             br-ed5 br-ed6 file))
  1454.     (br-ed5
  1455.      (start-process name name editor-cmd br-ed1 br-ed2 br-ed3 br-ed4
  1456.             br-ed5 file))
  1457.     (br-ed4
  1458.      (start-process name name editor-cmd br-ed1 br-ed2 br-ed3 br-ed4
  1459.             file))
  1460.     (br-ed3
  1461.      (start-process name name editor-cmd br-ed1 br-ed2 br-ed3 file))
  1462.     (br-ed2
  1463.      (start-process name name editor-cmd br-ed1 br-ed2 file))
  1464.     (br-ed1
  1465.      (start-process name name editor-cmd br-ed1 file))
  1466.     (t
  1467.      (start-process name name editor-cmd file))
  1468.     ))
  1469.  
  1470. (defun br-funcall-in-view-window (buffer function &optional no-erase)
  1471.   "Clear out BUFFER and display return value from invocation of FUNCTION in viewer window.
  1472. Move point to beginning of buffer and then return to current window.  BUFFER
  1473. may be a buffer name.
  1474. With optional NO-ERASE, buffer is not erased before function is called."
  1475.   (interactive)
  1476.   (let ((wind (selected-window)))
  1477.     (unwind-protect
  1478.     (progn (br-to-view-window)
  1479.            (set-window-buffer (selected-window) (get-buffer-create buffer))
  1480.            (let (buffer-read-only)
  1481.          (if no-erase
  1482.              (goto-char (point-min))
  1483.            (erase-buffer))
  1484.          (funcall function))
  1485.            (goto-char (point-min)))
  1486.       (select-window wind))))
  1487.  
  1488. (defun br-file-to-viewer (filename)
  1489.   "Display FILENAME from OO-Browser source directory in browser viewer window.
  1490. FILENAME should not contain any path information."
  1491.   (br-funcall-in-view-window
  1492.    (concat br-buffer-prefix-info "Help")
  1493.    (function (lambda ()
  1494.            (insert-file-contents (br-pathname filename))
  1495.            (set-buffer-modified-p nil)))))
  1496.  
  1497. (defun br-in-browser ()
  1498.   "Return selected frame if the OO-Browser is active in it, else return nil."
  1499.   (cond ((not (eq br-in-browser (selected-frame))) nil)
  1500.     ((one-window-p 'nomini)
  1501.      (setq br-in-browser nil))
  1502.     (t br-in-browser)))
  1503.  
  1504.  
  1505. (defun br-in-top-buffer-p ()
  1506.   "Return t if point is in the top class listing buffer, else nil."
  1507.   (string-equal (br-buffer-level) "1"))
  1508.  
  1509. (defun br-in-view-window-p ()
  1510.   "Is point in a viewer window?"
  1511.   (br-non-listing-window-p))
  1512.  
  1513. (defun br-init ()
  1514.   "Initialization common to all OO-Browser invocations."
  1515.   (br-feature-tags-init))
  1516.  
  1517. (defun br-insert-classes (class-list &optional indent)
  1518.   "Insert CLASS-LIST in current buffer indented INDENT columns."
  1519.   (mapcar (function
  1520.         (lambda (class-name)
  1521.           (and indent (indent-to indent))
  1522.           (and class-name (insert class-name "\n"))))
  1523.       class-list))
  1524.  
  1525. (defun br-interrupt (&optional arg)
  1526.   (if (not (br-in-browser))
  1527.       nil
  1528.     (if (null arg)
  1529.     (mapcar
  1530.      (function
  1531.       (lambda (buf)
  1532.         (if (or (eq (cdr (assq 'major-mode (buffer-local-variables buf)))
  1533.             'br-mode)
  1534.             (br-browser-buffer-p buf))
  1535.         (bury-buffer buf))))
  1536.      (buffer-list))
  1537.       (setq *br-save-wconfig* nil
  1538.         *br-prev-wconfig* nil
  1539.         *br-prev-listing-window* nil)
  1540.       (mapcar
  1541.        (function
  1542.     (lambda (buf)
  1543.       (set-buffer buf)
  1544.       (if (or (eq major-mode 'br-mode)
  1545.           (br-browser-buffer-p))
  1546.           (progn (br-feature-clear-signatures)
  1547.              (set-buffer-modified-p nil)
  1548.              (kill-buffer (current-buffer))))))
  1549.        (buffer-list))
  1550.       (br-cleanup))
  1551.     (setq br-in-browser nil)))
  1552.  
  1553. (defun br-mode ()
  1554.   "The major mode used by OO-Browser listing windows.
  1555. See the file \"br-help\" for browser usage information.
  1556. It provides the following keys: \\{br-mode-map}"
  1557.   (interactive)
  1558.   (use-local-map br-mode-map)
  1559.   (setq major-mode 'br-mode)
  1560.   (setq mode-name "OO-Browse")
  1561.   (set-syntax-table text-mode-syntax-table)
  1562.   (setq local-abbrev-table text-mode-abbrev-table)
  1563.   (setq case-fold-search t)
  1564.   (setq buffer-read-only t)
  1565.   (run-hooks 'br-class-list-hook)
  1566.   (run-hooks 'br-mode-hook))
  1567.  
  1568. (defun br-narrow-to-class ()
  1569.   (cond ((= (point-min) (point-max)) nil)
  1570.     ((br-find-class-name)
  1571.      (narrow-to-region (match-beginning 0) (match-end 0)))
  1572.     (t (error
  1573.         "(OO-Browser):  'br-narrow-to-class', current entry is not a class"))))
  1574.  
  1575. (defun br-narrow-to-feature ()
  1576.   "Narrow buffer to current feature entry."
  1577.   (if (br-feature-at-p)
  1578.       (narrow-to-region (match-beginning 0) (match-end 0))
  1579.     (error
  1580.      "(OO-Browser):  'br-narrow-to-feature' no current feature.")))
  1581.  
  1582. (defun br-feature-at-p ()
  1583.   "Returns t iff point is on a feature listing line."
  1584.   (save-excursion
  1585.     (beginning-of-line)
  1586.     (looking-at (concat "[ \t]*" br-feature-entry))))
  1587.  
  1588. (defun br-next-buffer (&optional special alt-prefix)
  1589.   "Returns next sequential browser buffer or special one if optional SPECIAL is non-nil.
  1590. Non-nil ALT-PREFIX is used as prefix in buffer name."
  1591.   (let* ((suffix (or special (1+ (or (br-class-level) 0))))
  1592.      (buf (get-buffer-create
  1593.            (concat (or alt-prefix br-buffer-prefix)
  1594.               (if (integerp suffix)
  1595.               (int-to-string suffix)
  1596.             suffix)))))
  1597.     (if buf (progn
  1598.           (or special (br-next-listing-window))
  1599.           (set-window-buffer (selected-window) buf)
  1600.           (let (buffer-read-only)
  1601.         (erase-buffer)
  1602.         (kill-all-local-variables)
  1603.         ;; Clear out any feature tags that may have been associated
  1604.         ;; with this buffer, so we don't mistakenly reference them.
  1605.         (br-feature-clear-signatures))
  1606.           (setq mode-line-format (list "  %17b --" '(-3 . "%p") "-%-"))
  1607.           (br-mode)
  1608.           (br-set-mode-line)
  1609.           (set-buffer-modified-p nil)))
  1610.     buf))
  1611.  
  1612. (defun br-next-listing-window (&optional prev)
  1613.   "Move to next browser listing window (non-viewer window).
  1614. Optional PREV means to previous window."
  1615.   (let ((owind (selected-window)))
  1616.     (while (progn (other-window (if prev -1 1))
  1617.           (if (br-non-listing-window-p)
  1618.               (not (eq (selected-window) owind)))))))
  1619.  
  1620. (defun br-pathname (filename)
  1621.   "Return full pathname for FILENAME in browser Elisp directory."
  1622.   (if br-directory
  1623.       (expand-file-name filename br-directory)
  1624.     (error "The 'br-directory' variable must be set to a string value.")))
  1625.  
  1626. (defun br-protocol-entry-p ()
  1627.   "Return non-nil if point is within a protocol listing entry line."
  1628.   (and (string-equal br-lang-prefix "objc-")
  1629.        (save-excursion
  1630.      (beginning-of-line)
  1631.      (looking-at "[ \t]*@ <[^\>]*>"))))
  1632.  
  1633. (defun br-resize (min-width)
  1634.   "Resize browser listing windows to have MIN-WIDTH."
  1635.   (interactive)
  1636.   (let* ((window-min-width 3)
  1637.      (oldn (1- (length (br-window-list))))
  1638.      (n (max 1 (/ (frame-width) min-width)))
  1639.      (numw n)
  1640.      (diff (- numw oldn))
  1641.      (width (/ (frame-width) numw))
  1642.      (obuf (current-buffer)))
  1643.     (br-to-first-list-window)
  1644.     (cond ((= diff 0)
  1645.        (br-resize-windows numw width))
  1646.       ((> diff 0)
  1647.        (setq n oldn)
  1648.        (while (> n 1)
  1649.          (setq n (1- n))
  1650.          (shrink-window-horizontally (max 0 (- (window-width)
  1651.                            min-width)))
  1652.          (br-next-listing-window))
  1653.        (setq n diff)
  1654.        (while (> n 0)
  1655.          (setq n (1- n))
  1656.          (split-window-horizontally (max window-min-width
  1657.                          (- (window-width)
  1658.                         min-width)))) 
  1659.        (setq n oldn)
  1660.        (while (< n numw)
  1661.          (setq n (1+ n))
  1662.          (br-next-listing-window)
  1663.          (br-next-buffer n br-buffer-prefix-blank))
  1664.        (br-to-first-list-window)
  1665.        (br-resize-windows numw width)
  1666.        )
  1667.       (t  ;; (< diff 0)
  1668.        (while (> n 0)
  1669.          (setq n (1- n))
  1670.          (br-next-listing-window))
  1671.        (setq n (- diff))
  1672.        (while (> n 0)
  1673.          (setq n (1- n))
  1674.          (delete-window))
  1675.        (br-to-first-list-window)
  1676.        (br-resize-windows numw width)
  1677.        ))
  1678.     (setq br-min-width-window min-width)
  1679.     (let ((owind (get-buffer-window obuf)))
  1680.       (if owind
  1681.       (select-window owind)
  1682.     (br-to-view-window)
  1683.     (br-next-listing-window)))))
  1684.  
  1685. (defun br-resize-narrow ()
  1686.   "Resize listing windows so are narrower by 10 characters."
  1687.   (interactive)
  1688.   (if (<= window-min-width (- br-min-width-window 10))
  1689.       (br-resize (max window-min-width (- br-min-width-window 10)))
  1690.     (beep)))
  1691.  
  1692. (defun br-resize-widen ()
  1693.   "Resize listing windows so are wider by 10 characters."
  1694.   (interactive)
  1695.   (if (and (>= (frame-width) (+ br-min-width-window 10))
  1696.        (> (length (br-window-list)) 2))
  1697.       (br-resize (min (frame-width) (+ br-min-width-window 10)))
  1698.     (beep)))
  1699.  
  1700. (defun br-resize-windows (n width)
  1701.   (while (> n 1)
  1702.     (setq n (1- n))
  1703.     (shrink-window-horizontally (- (window-width) width))
  1704.     (br-next-listing-window)))
  1705.  
  1706. (defun br-set-mode-line ()
  1707.   "Set mode line string."
  1708.   (setq mode-line-buffer-identification (list (buffer-name)))
  1709.   (set-buffer-modified-p t))
  1710.  
  1711. (defun br-show-top-classes (func &optional uniq)
  1712.   "Display list of top level classes generated by calling FUNC.
  1713. Optional UNIQ means sort and eliminate duplicates."
  1714.   (message "Ordering classes...")
  1715.   (let ((classes (funcall func)))
  1716.     (setq classes (br-class-list-filter classes))
  1717.     (br-clear)
  1718.     (let (buffer-read-only)
  1719.       (erase-buffer)
  1720.       (br-insert-classes classes)
  1721.       (if uniq
  1722.       (progn
  1723.         (if (stringp br-sort-options)
  1724.         (call-process-region (point-min) (point-max) "sort" t t nil
  1725.                      br-sort-options)
  1726.           (call-process-region (point-min) (point-max) "sort" t t nil))
  1727.         (if (and (stringp br-sort-options)
  1728.              (string-match "u" br-sort-options))
  1729.         ;; Then sort made the list of elements unique, so do nothing.
  1730.         nil
  1731.           (call-process-region (point-min) (point-max) "uniq" t t))))))
  1732.   (goto-char (point-min))
  1733.   (message "Ordering classes...Done"))
  1734.  
  1735. (defun br-this-level-classes (&optional keep-indent)
  1736.   "Return list of the classes in the current listing.
  1737. Optional KEEP-INDENT non-nil means keep indentation preceding class name."
  1738.   (let ((classes))
  1739.     (save-excursion
  1740.       (goto-char (point-min))
  1741.       (while (and (not (looking-at "^[ \t]*$"))
  1742.           (if (looking-at (format "^[ \t]*%s "
  1743.                       br-feature-type-regexp)) ;; a feature
  1744.               t ;; skip this entry
  1745.             ;; assume is a class
  1746.             (setq classes (cons (br-find-class-name keep-indent)
  1747.                     classes)))
  1748.           (= (forward-line 1) 0))))
  1749.     (nreverse (delq nil classes))))
  1750.  
  1751. (defun br-this-level-entries ()
  1752.   "Return list of all entries in the current listing."
  1753.   (let ((entries))
  1754.     (save-excursion
  1755.       (goto-char (point-min))
  1756.       (while (and (not (looking-at "^[ \t]*$"))
  1757.           (if (looking-at (format "^[ \t]*%s "
  1758.                       br-feature-type-regexp)) ;; a feature
  1759.               (setq entries
  1760.                 (cons (br-find-feature-entry) entries))
  1761.             ;; assume is a class
  1762.             (setq entries (cons (br-find-class-name) entries)))
  1763.           (= (forward-line 1) 0))))
  1764.     (nreverse (delq nil entries))))
  1765.  
  1766. (defun br-this-level-features ()
  1767.   "Return list of features in the current listing."
  1768.   (let ((feature-regexp (concat "[ \t]*" br-feature-entry))
  1769.     (features))
  1770.     (save-excursion
  1771.       (goto-char (point-min))
  1772.       (while (progn (if (looking-at feature-regexp)
  1773.             (setq features
  1774.                   (cons (br-find-feature-entry) features)))
  1775.             (= (forward-line 1) 0))))
  1776.     (nreverse (delq nil features))))
  1777.  
  1778. (defun br-to-first-list-window ()
  1779.   (br-to-view-window)
  1780.   (br-next-listing-window))
  1781.  
  1782. (defun br-to-tree ()
  1783.   "If point is within ... move to inher/ancestry expansion for the current class."
  1784.   (if (save-excursion
  1785.     (skip-chars-backward ".")
  1786.     (looking-at "\\.\\.\\."))
  1787.       (progn (beginning-of-line)
  1788.          (let ((class-expr (concat "^[ \t]*"
  1789.                        (br-find-class-name)
  1790.                        "$")))
  1791.            (if (re-search-backward class-expr nil t)
  1792.            (progn (skip-chars-forward " \t")
  1793.               (recenter '(4))
  1794.               t))))))
  1795.  
  1796. (defun br-to-view-window ()
  1797.   "Move to viewer window."
  1798.   (if (br-in-view-window-p)
  1799.       nil
  1800.     (setq *br-prev-listing-window* (selected-window))
  1801.     (while (and (not (br-in-view-window-p))
  1802.         (progn (other-window 1)
  1803.                (not (eq (selected-window)
  1804.                 *br-prev-listing-window*)))))))
  1805.  
  1806. (defun br-window-setup ()
  1807.   (and (fboundp 'modify-frame-parameters)
  1808.        (cdr (assq 'unsplittable (frame-parameters)))
  1809.        (modify-frame-parameters (selected-frame) '((unsplittable))))
  1810.   (delete-other-windows)
  1811.   ;; Set top of frame line in case it is not 0.
  1812.   (or (fboundp 'window-highest-p)
  1813.       (setq br-top-of-frame (nth 1 (window-edges))))
  1814.   (split-window-vertically nil)
  1815.   (let* ((n (max 1 (/ (frame-width) br-min-width-window)))
  1816.      (width (/ (frame-width) n)))
  1817.     (br-next-buffer 1)
  1818.     (while (> n 1)
  1819.       (setq n (1- n))
  1820.       (split-window-horizontally width)
  1821.       (br-next-buffer nil br-buffer-prefix-blank))))
  1822.  
  1823. (defun br-view-ext-start (viewer-cmd name file)
  1824.   "Start an external viewer given by VIEWER-CMD using NAME applied to FILE."
  1825.   ;; Conditionalized code is necessary because of silly (start-process) calling
  1826.   ;; protocol.
  1827.   (cond (br-vw9
  1828.      (start-process name name viewer-cmd br-vw1 br-vw2 br-vw3 br-vw4
  1829.             br-vw5 br-vw6 br-vw7 br-vw8 br-vw9 file))
  1830.     (br-vw8
  1831.      (start-process name name viewer-cmd br-vw1 br-vw2 br-vw3 br-vw4
  1832.             br-vw5 br-vw6 br-vw7 br-vw8 file))
  1833.     (br-vw7
  1834.      (start-process name name viewer-cmd br-vw1 br-vw2 br-vw3 br-vw4
  1835.             br-vw5 br-vw6 br-vw7 file))
  1836.     (br-vw6
  1837.      (start-process name name viewer-cmd br-vw1 br-vw2 br-vw3 br-vw4
  1838.             br-vw5 br-vw6 file))
  1839.     (br-vw5
  1840.      (start-process name name viewer-cmd br-vw1 br-vw2 br-vw3 br-vw4
  1841.             br-vw5 file))
  1842.     (br-vw4
  1843.      (start-process name name viewer-cmd br-vw1 br-vw2 br-vw3 br-vw4
  1844.             file))
  1845.     (br-vw3
  1846.      (start-process name name viewer-cmd br-vw1 br-vw2 br-vw3 file))
  1847.     (br-vw2
  1848.      (start-process name name viewer-cmd br-vw1 br-vw2 file))
  1849.     (br-vw1
  1850.      (start-process name name viewer-cmd br-vw1 file))
  1851.     (t
  1852.      (start-process name name viewer-cmd file))
  1853.     ))
  1854.  
  1855. ;;; ************************************************************************
  1856. ;;; Private variables
  1857. ;;; ************************************************************************
  1858.  
  1859. (defvar br-ancestor-function nil
  1860.   "If non-nil, a function of 3 arguments called after each ancestor class is inserted into an ancestry listing.
  1861. First argument is the class just inserted, second argument is a flag
  1862. indicating whether class has previously been displayed within the listing and
  1863. third argument is the number of spaces to indent each feature entry for this
  1864. class.")
  1865.  
  1866. (defvar br-top-of-frame 0
  1867.   "Frame line number of windows at top of the OO-Browser frame.")
  1868.  
  1869. (defvar br-ed-num 0)
  1870. (defvar br-ed-name "extEd")
  1871. (defvar br-vw-num 0)
  1872. (defvar br-vw-name "extVw")
  1873.  
  1874. (defvar br-in-browser nil
  1875.   "Equal to the frame displaying the OO-Browser when in use, else nil.")
  1876.  
  1877. (defvar br-lib-search-dirs nil
  1878.   "List of directories below which OO source files and other library
  1879. directories are found.  A library is a stable group of OO classes.  Do not
  1880. set this variable directly.  Each OO language library which invokes
  1881. 'br-browse' should set it.")
  1882.  
  1883. (defvar br-sys-search-dirs nil
  1884.   "List of directories below which OO source files and other system
  1885. directories are found.  A system is a group of OO classes that are likely to
  1886. change.  Do not set this variable directly.  Each OO language library which
  1887. invokes 'br-browse' should set it.")
  1888.  
  1889. (defvar *br-level-hist* nil
  1890.   "Internal history of visited listing windows and buffers.")
  1891.  
  1892. (defvar *br-prev-listing-window* nil
  1893.   "Saves listing window used prior to viewer window entry.
  1894. Allows return to previous listing window when done with the viewer.")
  1895.  
  1896. (defvar *br-prev-wconfig* nil
  1897.   "Saves window configuration prior to browser entry.")
  1898.  
  1899. (defvar *br-save-wconfig* nil
  1900.   "Saves window configuration between invocations of the browser.")
  1901.  
  1902. (defconst br-buffer-prefix-categ "Categ-Lvl-")
  1903. (defconst br-buffer-prefix-inher "Inher-Lvl-")
  1904. (defconst br-buffer-prefix-blank "Blank-")
  1905. (defconst br-buffer-prefix-info "OO-Browser ")
  1906. (defvar br-buffer-prefix br-buffer-prefix-inher
  1907.   "Browser buffer name prefix.")
  1908.  
  1909.  
  1910. (defvar br-mode-map nil
  1911.   "Keymap containing OO-Browser commands.")
  1912. (if br-mode-map
  1913.     nil
  1914.   (setq br-mode-map (make-keymap))
  1915.   (suppress-keymap br-mode-map)
  1916.   (define-key br-mode-map "@"        'br-at)
  1917.   (define-key br-mode-map "1"        'br-view-full-frame)
  1918.   (define-key br-mode-map "\C-c^"    'br-add-class-file)
  1919.   (define-key br-mode-map "a"        'br-ancestors)
  1920.   (define-key br-mode-map "b"        'br-buffer-menu)
  1921.   (define-key br-mode-map "c"        'br-children)
  1922.   (define-key br-mode-map "C"        'br-categories)
  1923.   (define-key br-mode-map "\M-c"     'br-class-stats)
  1924.   (define-key br-mode-map "\C-c\C-c" 'br-env-create)
  1925.   (define-key br-mode-map "d"        'br-descendants)
  1926.   (define-key br-mode-map "\C-c\C-d" 'br-delete)
  1927.   ;; {M-d} is used down below for 'br-tree'
  1928.   (define-key br-mode-map "e"        'br-edit-entry)
  1929.   (define-key br-mode-map "\M-e"     'br-env-stats)
  1930.   (define-key br-mode-map "\C-c\C-e" 'br-env-rebuild)
  1931.   (define-key br-mode-map "f"        'br-features)
  1932.   (define-key br-mode-map "F"        'br-feature-signature)
  1933.   ;; {M-f} is used down below for 'br-tree-features-toggle'
  1934.   ;; {M-g} is used down below for 'br-tree-graph'
  1935.   (define-key br-mode-map "?"        'br-help)
  1936.   (define-key br-mode-map "h"        'br-help)
  1937.   (define-key br-mode-map "H"        'br-help-ms) ;; mouse help
  1938.   (define-key br-mode-map "i"        'br-entry-info)
  1939.   (define-key br-mode-map "I"        'br-implementors)
  1940.   (define-key br-mode-map "\C-c\C-k" 'br-kill)
  1941.   ;; {M-k} is used down below for 'br-tree-kill'
  1942.   (define-key br-mode-map "l"        'br-lib-top-classes)
  1943.   (define-key br-mode-map "L"        'br-lib-rebuild)
  1944.   (define-key br-mode-map "\C-c\C-l" 'br-env-load)
  1945.   (define-key br-mode-map "m"        'br-match)
  1946.   (define-key br-mode-map "M"        'br-match-entries)
  1947.   ;; "\C-c\C-m" is reserved for future use.
  1948.   (define-key br-mode-map "\C-n"     'br-next-entry)
  1949.   (define-key br-mode-map "o"        'br-order)
  1950.   (define-key br-mode-map "p"        'br-parents)
  1951.   (define-key br-mode-map "P"        'br-protocols)
  1952.   (define-key br-mode-map "\C-p"     'br-prev-entry)
  1953.   (define-key br-mode-map "q"        'br-quit)
  1954.   ;; {r} does the same thing as {f} and is for backward compatibility
  1955.   ;; with prior OO-Browser releases.  It may be rebound in the future, so
  1956.   ;; learn to use {f} instead.
  1957.   (define-key br-mode-map "r"        'br-features)
  1958.   (define-key br-mode-map "\C-c\C-r" 'br-refresh)
  1959.   (define-key br-mode-map "s"        'br-sys-top-classes)
  1960.   (define-key br-mode-map "S"        'br-sys-rebuild)
  1961.   (define-key br-mode-map "\C-c\C-s" 'br-env-save)
  1962.   (define-key br-mode-map "t"        'br-top-classes)
  1963.   (define-key br-mode-map "u"        'br-unique)
  1964.   (define-key br-mode-map "v"        'br-view-entry)
  1965.   (define-key br-mode-map "V"        'br-view-friend)
  1966.   (define-key br-mode-map "\C-c\C-v" 'br-to-from-viewer)
  1967.   (define-key br-mode-map "\C-c\C-w" 'br-write-buffer)
  1968.   (define-key br-mode-map "w"        'br-where)
  1969.   (define-key br-mode-map "x"        'br-exit-level)
  1970.   (define-key br-mode-map "\C-x-"    'br-resize-narrow)
  1971.   (define-key br-mode-map "\C-x+"    'br-resize-widen)
  1972.   (define-key br-mode-map "#"        'br-count)
  1973.   (define-key br-mode-map "\C-c#"    'br-version)
  1974.   (define-key br-mode-map " "        'br-viewer-scroll-up)
  1975.   (define-key br-mode-map "\177"     'br-viewer-scroll-down)
  1976.   ;;
  1977.   ;; Define graphical browser keys if a window system is available.
  1978.   (if hyperb:window-system
  1979.       (progn (require 'br-tree)
  1980.          (define-key br-mode-map "\M-d" 'br-tree)
  1981.          (define-key br-mode-map "\M-f" 'br-tree-features-toggle)
  1982.          (define-key br-mode-map "\M-g" 'br-tree-graph)
  1983.          (define-key br-mode-map "\M-k" 'br-tree-kill))))
  1984.  
  1985. (defvar br-tmp-class-set nil
  1986.   "Set of classes created for temporary use by br-*-trees functions.")
  1987. (defvar br-tmp-depth 0
  1988.   "Temporary variable indicating inheritance depth of class in 'br-ancestor-trees'.")
  1989.  
  1990. (provide 'br)
  1991.